home *** CD-ROM | disk | FTP | other *** search
/ QRZ! Ham Radio 8 / QRZ Ham Radio Callsign Database - Volume 8.iso / pc / files / ant_nec / nec81tar.z / nec81tar / datagn.f < prev    next >
Text File  |  1991-05-13  |  23KB  |  905 lines
  1. C $TITLE: 'DATAGN'
  2. C $NOFLOATCALLS
  3.       SUBROUTINE DATAGN(CM,ZARRAY,X,Y,Z,BI,SALP,T1X,T1Y,T1Z,T2X,T2Y,
  4.      1 T2Z,ICON1,ICON2,ITAG,ICONX,IP,LD,LD2,IRESRV,IR,IW,IGFL)
  5. C
  6. C     DATAGN IS THE MAIN ROUTINE FOR INPUT OF GEOMETRY DATA.
  7. C
  8. C***
  9.       REAL*8 TA,TD,ATGN2,XW1,YW1,ZW1,XW2,YW2,ZW2
  10. CLARGE: CM
  11.       COMPLEX CM
  12.       COMPLEX*16 ZARRAY
  13.       INTEGER*4 ICON1,ICON2,ITAG,ICONX,N1,N2,N,NP,M1,
  14.      1 M2,M,MP,IPSYM,IPSAV
  15.          CHARACTER*2 ATST,AGM
  16.       CHARACTER*1 APT,AFX,AFY,AFZ
  17. C***
  18.       COMMON/DATAD/N1,N2,N,NP,M1,M2,M,MP,IPSYM,WLAM
  19. C***
  20.       COMMON/PLOT/ IPLP1,IPLP2,IPLP3,IPLP4
  21. C***
  22.       DIMENSION CM(IRESRV),ZARRAY(LD)
  23.       DIMENSION ICON1(LD),ICON2(LD),ITAG(LD),ICONX(LD),IP(LD2)
  24.       DIMENSION X(LD),Y(LD),Z(LD),BI(LD),SALP(LD),
  25.      1 T1X(LD),T1Y(LD),T1Z(LD),T2X(LD),T2Y(LD),T2Z(LD)
  26. C***
  27. C***    GP STUFF  SUPPRESS GEOMETRY PRINT  RWA 29 MAR 89  CHNG 1 LINE
  28. C***
  29.       DIMENSION AFX(2),AFY(2),AFZ(2),APT(4),ATST(14)
  30. C**
  31. C $NODEBUG
  32. C**
  33. C***
  34. C***    GP STUFF  SUPPRESS GEOMETRY PRINT  RWA 29 MAR 89  CHNG 1 LINE
  35. C***
  36.       DATA ATST/2HGW,2HGX,2HGR,2HGS,2HGE,2HGM,2HSP,2HSM,2HGF,2HGA,
  37.      1 2HSC,2HGC,2HGP,2HGH/
  38.       DATA AFX/1H ,1HX/,AFY/1H ,1HY/,AFZ/1H ,1HZ/
  39.       DATA TA/0.01745329252D0/,TD/57.29577951D0/,APT/1HP,1HR,1HT,1HQ/
  40. C***
  41. $DEBUG
  42. C**
  43. C**
  44. C     D      WRITE(*,*) '  DATAGN: START'
  45. C**
  46. C***
  47. C***    GP STUFF  SUPPRESS GEOMETRY PRINT  RWA 39 MAR 89  ADD 1 LINE
  48. C***
  49.       IGPFLG = 0
  50.       IPSYM=0
  51.       NWIRE=0
  52.       N=0
  53.       NP=0
  54.       M=0
  55.       MP=0
  56.       N1=0
  57.       N2=1
  58.       M1=0
  59.       M2=1
  60.       ISCT=0
  61.       IPHD=0
  62. C
  63. C     READ GEOMETRY DATA CARD AND BRANCH TO SECTION FOR OPERATION
  64. C     REQUESTED
  65. C
  66. 1     READ (IR,42) AGM,ITG,NS,XW1,YW1,ZW1,XW2,YW2,ZW2,RAD
  67.       IF (N+M.GT.LD) GO TO 37
  68.       IF (AGM.EQ.ATST(9)) GO TO 27
  69.       IF (IPHD.EQ.1) GO TO 2
  70.       WRITE(IW,40)
  71.       WRITE(IW,41)
  72.       IPHD=1
  73. C**
  74. 2     IF (AGM.EQ.ATST(11)) GO TO 10
  75.       ISCT=0
  76. C***
  77. C***    GP STUFF  SUPPRESS GEOMETRY PRINT  RWA 29 MAR 89  ADD 1 LINE
  78. C***
  79.       IF (AGM.EQ.ATST(13)) GO TO 311
  80.       IF (AGM.EQ.ATST(1)) GO TO 3
  81.       IF (AGM.EQ.ATST(2)) GO TO 18
  82.       IF (AGM.EQ.ATST(3)) GO TO 19
  83.       IF (AGM.EQ.ATST(4)) GO TO 21
  84.       IF (AGM.EQ.ATST(7)) GO TO 9
  85.       IF (AGM.EQ.ATST(8)) GO TO 13
  86.       IF (AGM.EQ.ATST(5)) GO TO 29
  87.       IF (AGM.EQ.ATST(6)) GO TO 26
  88.       IF (AGM.EQ.ATST(10)) GO TO 8
  89. C***
  90. C***
  91. C***    GP STUFF  SUPPRESS GEOMETRY PRINT  RWA 39 MAR 89  CHNG 1 LINE
  92. C***
  93.       IF (AGM.EQ.ATST(14)) GO TO 123
  94. C***
  95.       GO TO 36
  96. C
  97. C     GENERATE SEGMENT DATA FOR STRAIGHT WIRE.
  98. C
  99. 3     NWIRE=NWIRE+1
  100.       I1=N+1
  101.       I2=N+NS
  102.       WRITE(IW,43)  NWIRE,XW1,YW1,ZW1,XW2,YW2,ZW2,RAD,NS,I1,I2,ITG
  103.       IF (RAD.EQ.0) GO TO 4
  104.       XS1=1.
  105.       YS1=1.
  106.       GO TO 7
  107. 4     READ (IR,42) AGM,IX,IY,XS1,YS1,ZS1
  108.       IF (AGM.EQ.ATST(12)) GO TO 6
  109. 5     WRITE(*,48)
  110.       STOP
  111. 6     WRITE(IW,61)  XS1,YS1,ZS1
  112.       IF (YS1.EQ.0.OR.ZS1.EQ.0) GO TO 5
  113.       RAD=YS1
  114.       YS1=(ZS1/YS1)**(1./(NS-1.))
  115. 7      CONTINUE
  116. C**
  117. C     D      WRITE(*,*) '  DATAGN: CALL WIRE'
  118. C**
  119.       CALL WIRE(X,Y,Z,BI,T1X,T1Y,T1Z,XW1,YW1,ZW1,XW2,YW2,ZW2,
  120.      1 RAD,XS1,YS1,ITAG,LD,NS,ITG)
  121. C**
  122.       GO TO 1
  123. C
  124. C     GENERATE SEGMENT DATA FOR WIRE ARC
  125. C
  126. 8     NWIRE=NWIRE+1
  127.       I1=N+1
  128.       I2=N+NS
  129.       WRITE(IW,38)  NWIRE,XW1,YW1,ZW1,XW2,NS,I1,I2,ITG
  130. C**
  131. C     E      WRITE(*,*) '  DATAGN: CALL ARC'
  132. C**
  133.       CALL ARC(ITG,NS,XW1,YW1,ZW1,XW2,X,Y,Z,BI,ITAG,T1X,T1Y,T1Z,LD)
  134. C**
  135. C     E      WRITE(*,*) '  DATAGN: RTRN ARC'
  136. C**
  137.       GO TO 1
  138. 123   NWIRE=NWIRE+1
  139.       I1=N+1
  140.       I2=N+NS
  141. C***
  142. C***    GH STUFF  NEW HELIX FROM NEC3  RWA 1 APR 89  WILL CHNG 2 LINES
  143. C***
  144.       WRITE(IW,124) XW1,YW1,NWIRE,ZW1,XW2,YW2,ZW2,RAD,NS,I1,I2,ITG
  145. C***  WRITE (IW,124) XW2,ZW1,NWIRE,XW1,YW1,YW2,NS,I1,I1,ITG
  146. C***  CALL HELIX(IW,ITG,NS,XW1,YW1,ZW1,XW2,YW2,X,Y,Z,
  147. C*** 1 BI,ITAG,T1X,T1Y,T1Z,LD)
  148. C**
  149. C     E      WRITE(*,*) '  DATAGN: CALL HELIX'
  150. C**
  151.       CALL HELIX(IW,XW1,YW1,ZW1,XW2,YW2,ZW2,RAD,NS,ITG,X,Y,Z,
  152.      1 BI,ITAG,T1X,T1Y,T1Z,LD)
  153. C**
  154. C     E      WRITE(*,*) '  DATAGN: RTRN HELIX'
  155. C**
  156.       GO TO 1
  157. C
  158. 124   FORMAT(5X,'HELIX STRUCTURE-   AXIAL SPACING BETWEEN TURNS =',F8.3,
  159.      1' TOTAL AXIAL LENGTH =',F8.3/1X,I5,2X,'RADIUS OF HELIX =',4(2X,
  160.      2F8.3),7X,F11.5,I8,4X,I5,1X,I5,3X,I5)
  161. C***
  162. C
  163. C     GENERATE SINGLE NEW PATCH
  164. C
  165. 9     I1=M+1
  166.       NS=NS+1
  167.       IF (ITG.NE.0) GO TO 17
  168.       WRITE(IW,51)  I1,APT(NS),XW1,YW1,ZW1,XW2,YW2,ZW2
  169.       IF (NS.EQ.2.OR.NS.EQ.4) ISCT=1
  170.       IF (NS.GT.1) GO TO 14
  171.       XW2=XW2*TA
  172.       YW2=YW2*TA
  173.       GO TO 16
  174. 10    IF (ISCT.EQ.0) GO TO 17
  175.       I1=M+1
  176.       NS=NS+1
  177.       IF (ITG.NE.0) GO TO 17
  178.       IF (NS.NE.2.AND.NS.NE.4) GO TO 17
  179.       XS1=X4
  180.       YS1=Y4
  181.       ZS1=Z4
  182.       XS2=X3
  183.       YS2=Y3
  184.       ZS2=Z3
  185.       X3=XW1
  186.       Y3=YW1
  187.       Z3=ZW1
  188.       IF (NS.NE.4) GO TO 11
  189.       X4=XW2
  190.       Y4=YW2
  191.       Z4=ZW2
  192. 11    XW1=XS1
  193.       YW1=YS1
  194.       ZW1=ZS1
  195.       XW2=XS2
  196.       YW2=YS2
  197.       ZW2=ZS2
  198.       IF (NS.EQ.4) GO TO 12
  199.       X4=XW1+X3-XW2
  200.       Y4=YW1+Y3-YW2
  201.       Z4=ZW1+Z3-ZW2
  202. 12    WRITE(IW,51)  I1,APT(NS),XW1,YW1,ZW1,XW2,YW2,ZW2
  203.       WRITE(IW,39)  X3,Y3,Z3,X4,Y4,Z4
  204.       GO TO 16
  205. C
  206. C     GENERATE MULTIPLE-PATCH SURFACE
  207. C
  208. 13    I1=M+1
  209.       WRITE(IW,59)  I1,APT(2),XW1,YW1,ZW1,XW2,YW2,ZW2,ITG,NS
  210.       IF (ITG.LT.1.OR.NS.LT.1) GO TO 17
  211. 14    READ (IR,42) AGM,IX,IY,X3,Y3,Z3,X4,Y4,Z4
  212.       IF (NS.NE.2.AND.ITG.LT.1) GO TO 15
  213.       X4=XW1+X3-XW2
  214.       Y4=YW1+Y3-YW2
  215.       Z4=ZW1+Z3-ZW2
  216. 15    WRITE(IW,39)  X3,Y3,Z3,X4,Y4,Z4
  217.       IF (AGM.NE.ATST(11)) GO TO 17
  218. 16      CONTINUE
  219. C**
  220. C     D      WRITE(*,*) '  DATAGN: CALL PATCH'
  221. C**
  222.       CALL PATCH (ITG,NS,XW1,YW1,ZW1,XW2,YW2,ZW2,X3,Y3,Z3,X4,Y4,Z4,
  223.      1 X,Y,Z,BI,SALP,T1X,T1Y,T1Z,T2X,T2Y,T2Z,LD)
  224. C**
  225. C     D      WRITE(*,*) '  DATAGN: RTRN PATCH'
  226. C**
  227.       GO TO 1
  228. 17    WRITE(*,60)
  229.       STOP
  230. C
  231. C     REFLECT STRUCTURE ALONG X,Y, OR Z AXES OR ROTATE TO FORM CYLINDER.
  232. C
  233. 18    IY=NS/10
  234.       IZ=NS-IY*10
  235.       IX=IY/10
  236.       IY=IY-IX*10
  237.       IF (IX.NE.0) IX=1
  238.       IF (IY.NE.0) IY=1
  239.       IF (IZ.NE.0) IZ=1
  240.       WRITE(IW,44)  AFX(IX+1),AFY(IY+1),AFZ(IZ+1),ITG
  241.       GO TO 20
  242. 19    WRITE(IW,45)  NS,ITG
  243.       IX=-1
  244. 20      CONTINUE
  245. C**
  246. C     D      WRITE(*,*) '  DATAGN: CALL REFLC'
  247. C**
  248.       CALL REFLC (IX,IY,IZ,ITG,NS,LD,X,Y,Z,BI,
  249.      1 ITAG,SALP,T1X,T1Y,T1Z,T2X,T2Y,T2Z,T1X,T1Y,T1Z)
  250. C**
  251. C     D      WRITE(*,*) '  DATAGN: RTRN REFLC'
  252. C**
  253.       GO TO 1
  254. C
  255. C     SCALE STRUCTURE DIMENSIONS BY FACTOR XW1.
  256. C
  257. C***
  258. C***    GS STUFF - SCALING OPTION  RWA 02 APR 89  ADD 5 LINES
  259. C***
  260. 21    IF (ITG-1) 211,212,213
  261. 212   XW1 = 0.3048
  262.       GO TO 211
  263. 213   XW1 = 0.0254
  264. 211   IF (N.LT.N2) GO TO 23
  265. CCC21      CONTINUE
  266. CCC   IF (N.LT.N2) GO TO 23
  267.       DO 22 I=N2,N
  268.       X(I)=X(I)*XW1
  269.       Y(I)=Y(I)*XW1
  270.       Z(I)=Z(I)*XW1
  271.       T1X(I)=T1X(I)*XW1
  272.       T1Y(I)=T1Y(I)*XW1
  273.       T1Z(I)=T1Z(I)*XW1
  274. 22    BI(I)=BI(I)*XW1
  275. 23      CONTINUE
  276.       IF (M.LT.M2) GO TO 25
  277.       YW1=XW1*XW1
  278.       IX=LD+1-M
  279.       IY=LD-M1
  280.       DO 24 I=IX,IY
  281.       X(I)=X(I)*XW1
  282.       Y(I)=Y(I)*XW1
  283.       Z(I)=Z(I)*XW1
  284. 24    BI(I)=BI(I)*YW1
  285. 25      CONTINUE
  286.       WRITE(IW,46)  XW1
  287.       GO TO 1
  288. C
  289. C     MOVE STRUCTURE OR REPRODUCE ORIGINAL STRUCTURE IN NEW POSITIONS.
  290. C
  291. 26      CONTINUE
  292.       WRITE(IW,47)  ITG,NS,XW1,YW1,ZW1,XW2,YW2,ZW2,RAD
  293.       XW1=XW1*TA
  294.       YW1=YW1*TA
  295.       ZW1=ZW1*TA
  296. C**
  297. C     D      WRITE(*,*) '  DATAGN: CALL MOVE'
  298. C**
  299. C***
  300. C***    GM STUFF - SELECTED MOVE OPTION  RWA 02 APR 89   ADD 3 LINES
  301. C***                                                     CHNG 2 LINES
  302.       RAD = RAD + .5E-3
  303.       IMOV1 = INT(RAD)
  304.       IMOV2 = INT((RAD - IMOV1)*1.E3)
  305. CCC   CALL MOVE (XW1,YW1,ZW1,XW2,YW2,ZW2,INT(RAD+.5),NS,ITG,LD,X,Y,Z,
  306. CCC  1 BI,ITAG,SALP,T1X,T1Y,T1Z,T2X,T2Y,T2Z,T1X,T1Y,T1Z)
  307.       CALL MOVE (XW1,YW1,ZW1,XW2,YW2,ZW2,IMOV1,IMOV2,NS,ITG,LD,X,Y,Z,
  308.      1 BI,ITAG,SALP,T1X,T1Y,T1Z,T2X,T2Y,T2Z,T1X,T1Y,T1Z)
  309. C**
  310. C     D      WRITE(*,*) '  DATAGN: RTRN MOVE'
  311. C**
  312.       GO TO 1
  313. C
  314. C     READ NUMERICAL GREEN'S FUNCTION TAPE
  315. C
  316. 27    IF (N+M.EQ.0) GO TO 28
  317.       WRITE(*,52)
  318.       STOP
  319. 28      CONTINUE
  320. C**
  321. C     D      WRITE(*,*) '  DATAGN: CALL GFIL'
  322. C**
  323.       CALL GFIL(CM,ZARRAY,X,Y,Z,T1X,BI,T1Y,T1Z,SALP,
  324.      1 ICON1,ICON2,ITAG,IP,IW,IGFL,ITG,LD,LD2,IRESRV)
  325. C**
  326. C     D      WRITE(*,*) '  DATAGN: RTRN GFIL'
  327. C**
  328.       NPSAV=NP
  329.       MPSAV=MP
  330.       IPSAV=IPSYM
  331.       GO TO 1
  332. C
  333. C     TERMINATE STRUCTURE GEOMETRY INPUT.
  334. C
  335. C***
  336. C***    GE 1,1 OPTION - GEOMETRY OUTPUT FOR GTD CURRENT
  337. C***      RWA 02 APR 89 - CHANGE 1 LINE
  338. C***
  339. 29    IF (XW1.GT.0) IRESRV=IFIX(XW1)
  340. CCC29      CONTINUE
  341.       IF(NS.EQ.0) GO TO 290
  342.       IPLP1=1
  343.       IPLP2=1
  344. C***
  345. C***    GE 1,2 OPTION - GEOMETRY OUTPUT FOR CURRPLOT
  346. C***      RWA 02 APR 89 - ADD 2 LINES
  347. C***
  348.       IF(NS.NE.2) GO TO 290
  349.       IPLP2 = 2
  350. 290   IX=N1+M1
  351. C***
  352.       IF (IX.EQ.0) GO TO 30
  353.       NP=N
  354.       MP=M
  355.       IPSYM=0
  356. 30      CONTINUE
  357. C**
  358. C     D      WRITE(*,*) '  DATAGN: CALL CONECT'
  359. C**
  360.       CALL CONECT(X,Y,Z,BI,SALP,T1X,T1Y,T1Z,T2X,T2Y,T2Z,
  361.      1 ICON1,ICON2,ICONX,ITG,IW,LD)
  362. C**
  363. C     D      WRITE(*,*) '  DATAGN: RTRN CONECT'
  364. C**
  365.       IF (IX.EQ.0) GO TO 31
  366.       NP=NPSAV
  367.       MP=MPSAV
  368.       IPSYM=IPSAV
  369. 31    IF (N+M.GT.LD) GO TO 37
  370.       IF (N.EQ.0) GO TO 33
  371.       WRITE(IW,53)
  372.       WRITE(IW,54)
  373.       DO 32 I=1,N
  374.       XW1=T1X(I)-X(I)
  375.       YW1=T1Y(I)-Y(I)
  376.       ZW1=T1Z(I)-Z(I)
  377.       X(I)=(X(I)+T1X(I))*.5
  378.       Y(I)=(Y(I)+T1Y(I))*.5
  379.       Z(I)=(Z(I)+T1Z(I))*.5
  380.       XW2=XW1*XW1+YW1*YW1+ZW1*ZW1
  381.       YW2=DSQRT(XW2)
  382.       YW2=(XW2/YW2+YW2)*.5
  383.       T1X(I)=YW2
  384.       T1Y(I)=XW1/YW2
  385.       T1Z(I)=YW1/YW2
  386.       XW2=ZW1/YW2
  387.       IF (XW2.GT.1.) XW2=1.
  388.       IF (XW2.LT.-1.) XW2=-1.
  389.       SALP(I)=XW2
  390.       XW2=DASIN(1.D0*XW2)*TD
  391.       YW2=ATGN2(YW1,XW1)*TD
  392. C***
  393. C***    GP STUFF - SUPPRESS GEOMETRY PRINT RWA 02 APR 89  ADD 1 LINE
  394. C***
  395.       IF (IGPFLG.EQ.1) GO TO 319
  396.       WRITE(IW,55) I,X(I),Y(I),Z(I),T1X(I),XW2,YW2,BI(I),ICON1(I),I,
  397.      1ICON2(I),ITAG(I)
  398. C***
  399. C***    GE 1,1 OPTION - GEOMETRY OUTPUT FOR GTD CURRENTS
  400. C***      RWA 02 APR 89  CHANGE 1 LINE
  401. C***
  402. 319   IF(IPLP1.NE.1) GO TO 320
  403. C***
  404. C***    GE 1,2 OPTION - GEOMETRY OUTPUT FOR CURRPLOT
  405. C***      RWA 02 APR 89  ADD 4 LINES
  406. C***
  407.       IF(IPLP2.NE.2)GO TO 3199
  408.       WRITE(8,*) X(I),Y(I),Z(I),T1X(I),I,ITAG(I)
  409.       GO TO 320
  410. 3199  CONTINUE
  411.       WRITE(8,*)X(I),Y(I),Z(I),T1X(I),XW2,YW2,BI(I),ICON1(I),I,ICON2(I)
  412. 320   CONTINUE
  413. C***
  414.       IF (T1X(I).GT.1.E-20.AND.BI(I).GT.0.) GO TO 32
  415.       WRITE(*,56)
  416.       STOP
  417. 32    CONTINUE
  418. 33    IF (M.EQ.0) GO TO 35
  419.       WRITE(IW,57)
  420.       J=LD+1
  421.       DO 34 I=1,M
  422.       J=J-1
  423.       XW1=(T1Y(J)*T2Z(J)-T1Z(J)*T2Y(J))*SALP(J)
  424.       YW1=(T1Z(J)*T2X(J)-T1X(J)*T2Z(J))*SALP(J)
  425.       ZW1=(T1X(J)*T2Y(J)-T1Y(J)*T2X(J))*SALP(J)
  426. C***
  427. C***    GP STUFF - SUPPRESS GEOMETRY PRINT  RWA 02 APR 89   ADD 1 LINE
  428. C***
  429.       IF(IGPFLG.EQ.1)GO TO 34
  430.       WRITE(IW,58) I,X(J),Y(J),Z(J),XW1,YW1,ZW1,BI(J),T1X(J),T1Y(J),
  431.      1T1Z(J),T2X(J),T2Y(J),T2Z(J)
  432. 34    CONTINUE
  433. 35      CONTINUE
  434. C**
  435. C     D        WRITE(*,*) '  DATAGN: RETURN'
  436. C**
  437.       RETURN
  438. C***
  439. C***    GP STUFF - SUPPRESS GEOMETRY PRINT  RWA 02 APR 89  ADD 2 LINES
  440. C***
  441. 311   IGPFLG =  1
  442.       GO TO 1
  443. 36    WRITE(IW,48)
  444.       WRITE(*,49)  AGM,ITG,NS,XW1,YW1,ZW1,XW2,YW2,ZW2,RAD
  445.       STOP
  446. 37    WRITE(*,50)
  447.       STOP
  448. C
  449. 38    FORMAT (1X,I5,2X,'ARC RADIUS =',F9.5,2X,'FROM',F8.3,' TO',F8.3,
  450.      1' DEGREES',11X,F11.5,2X,I5,4X,I5,1X,I5,3X,I5)
  451. 39    FORMAT (6X,3F11.5,1X,3F11.5)
  452. 40    FORMAT (////,33X,'- - - STRUCTURE SPECIFICATION - - -',//,37X,
  453.      1'COORDINATES MUST BE INPUT IN',/,37X,'METERS OR BE SCALED TO ',
  454.      2'METERS',/,37X,'BEFORE STRUCTURE INPUT IS ENDED',//)
  455. 41    FORMAT(2X,'WIRE',79X,'NO. OF',4X,'FIRST',2X,'LAST',5X,'TAG',/,
  456.      1 2X,'NO.',8X,'X1',9X,'Y1',9X,'Z1',10X,'X2',9X,'Y2',9X,'Z2',6X,
  457.      2'RADIUS',3X,'SEG.',5X,'SEG.',3X,'SEG.',5X,'NO.')
  458. 42    FORMAT (A2,I4,I5,7F10.5)
  459. 43    FORMAT (1X,I5,3F11.5,1X,4F11.5,2X,I5,4X,I5,1X,I5,3X,I5)
  460. 44    FORMAT(6X,'STRUCTURE REFLECTED ALONG THE AXES',3(1X,A1),
  461.      1'.TAGS INCREMENTED BY',I5)
  462. 45    FORMAT (6X,'STRUCTURE ROTATED ABOUT Z-AXIS',I3,' TIMES.  LABELS',
  463.      1' INCREMENTED BY',I5)
  464. 46    FORMAT (6X,'STRUCTURE SCALED BY FACTOR',F10.5)
  465. 47    FORMAT (6X,'THE STRUCTURE HAS BEEN MOVED, MOVE DATA CARD IS -',
  466.      1 /6X,I3,I5,7F10.5)
  467. 48    FORMAT (' GEOMETRY DATA CARD ERROR')
  468. 49    FORMAT (1X,A2,I3,I5,7F10.5)
  469. 50    FORMAT(' NUMBER OF WIRE SEGMENTS AND SURFACE PATCHES EXCEEDS',
  470.      1' DIMENSION LIMIT.')
  471. 51    FORMAT (1X,I5,A1,F10.5,2F11.5,1X,3F11.5)
  472. 52    FORMAT(' ERROR - GF MUST BE FIRST GEOMETRY DATA CARD')
  473. 53    FORMAT (////33X,'- - - - SEGMENTATION DATA - - - -',//,40X,
  474.      1'COORDINATES IN METERS',//,25X,'I+ AND I- INDICATE THE SEGMENTS',
  475.      2' BEFORE AND AFTER I',//)
  476. 54    FORMAT (2X,'SEG.',3X,'COORDINATES OF SEG. CENTER',5X,'SEG.',5X,
  477.      1'ORIENTATION ANGLES',4X,'WIRE',4X,'CONNECTION DATA',3X,'TAG',/,2X,
  478.      2'NO.',7X,'X',9X,'Y',9X,'Z',7X,'LENGTH',5X,'ALPHA',5X,'BETA',6X,
  479.      3'RADIUS',4X,'I-',3X,'I',4X,'I+',4X,'NO.')
  480. 55    FORMAT (1X,I5,4F10.5,1X,3F10.5,1X,3I5,2X,I5)
  481. 56    FORMAT(' SEGMENT DATA ERROR')
  482. 57    FORMAT (////,44X,'- - - SURFACE PATCH DATA - - -',//,49X,
  483.      1'COORDINATES IN METERS',//,1X,'PATCH',5X,'COORD. OF PATCH CENTER',
  484.      27X,'UNIT NORMAL VECTOR',6X,'PATCH',12X,'COMPONENTS OF UNIT ',
  485.      3'TANGENT VECTORS',/,2X,'NO.',6X,'X',9X,'Y',9X,'Z',9X,'X',7X,
  486.      4'Y',7X,'Z',7X,'AREA',7X,'X1',6X,'Y1',6X,'Z1',7X,'X2',6X,'Y2',
  487.      5 6X,'Z2')
  488. 58    FORMAT (1X,I4,3F10.5,1X,3F8.4,F10.5,1X,3F8.4,1X,3F8.4)
  489. 59    FORMAT (1X,I5,A1,F10.5,2F11.5,1X,3F11.5,5X,'SURFACE -',I4,' BY',
  490.      1 I3,' PATCHES')
  491. 60    FORMAT(' PATCH DATA ERROR')
  492. 61    FORMAT(9X,'ABOVE WIRE IS TAPERED.  SEG. LENGTH RATIO =',F9.5,/,
  493.      1 33X,'RADIUS FROM',F9.5,' TO',F9.5)
  494. C***
  495. C***    GH STUFF  HELIX-SPIRAL  RWA 2 APR 89   WILL ADD 3 LINES
  496. C***
  497. CCC124FORMAT(5X,' HELIX-SPIRAL STRUCTURE-  NUMBER OF TURNS =',F8.3,
  498. CCC  15X,' TOTAL AXIAL LENGTH =',F8.3/1X,I5,2X,'RADIUS OF HELIX =',2(2X,
  499. CCC  2F8.3),28X,F11.5,2X,I5,4X,I5,1X,I5,3X,I5)
  500.       END
  501. C***
  502. C***    GM STUFF  SELECTED MOVE  RWA 02 APR 89   CHANGE 2 LINES
  503. C
  504.       SUBROUTINE MOVE (ROX,ROY,ROZ,XS,YS,ZS,IXT1,IXT2,NRPT,ITGI,LD,
  505.      1 X,Y,Z,BI,ITAG,SALP,T1X,T1Y,T1Z,T2X,T2Y,T2Z,X2,Y2,Z2)
  506. C     SUBROUTINE MOVE (ROX,ROY,ROZ,XS,YS,ZS,ITS,NRPT,ITGI,LD,X,Y,Z,
  507. C    1 BI,ITAG,SALP,T1X,T1Y,T1Z,T2X,T2Y,T2Z,X2,Y2,Z2)
  508. C
  509. C     SUBROUTINE MOVE MOVES THE STRUCTURE WITH RESPECT TO ITS
  510. C     COORDINATE SYSTEM OR REPRODUCES STRUCTURE IN NEW POSITIONS.
  511. C     STRUCTURE IS ROTATED ABOUT X,Y,Z AXES BY ROX,ROY,ROZ
  512. C     RESPECTIVELY, THEN SHIFTED BY XS,YS,ZS
  513. C
  514.       INTEGER*4 ITAG,N1,N2,N,NP,M1,M2,M,MP,IPSYM
  515.       REAL*8 SPS,CPS,STH,CTH,SPH,CPH,XX,XY,XZ,YX,YY,YZ,ZX,ZY,ZZ
  516.       REAL*8 ROX,ROY,ROZ,XS,YS,ZS
  517.       COMMON/DATAD/N1,N2,N,NP,M1,M2,M,MP,IPSYM,WLAM
  518.       DIMENSION T1X(LD),T1Y(LD),T1Z(LD),T2X(LD),T2Y(LD),T2Z(LD),
  519.      1 X2(LD),Y2(LD),Z2(LD),ITAG(LD),X(LD),Y(LD),Z(LD),BI(LD),SALP(LD)
  520.       IF (ABS(ROX)+ABS(ROY).GT.1.D-10) IPSYM=IPSYM*3
  521.       SPS=DSIN(ROX)
  522.       CPS=DCOS(ROX)
  523.       STH=DSIN(ROY)
  524.       CTH=DCOS(ROY)
  525.       SPH=DSIN(ROZ)
  526.       CPH=DCOS(ROZ)
  527.       XX=CPH*CTH
  528.       XY=CPH*STH*SPS-SPH*CPS
  529.       XZ=CPH*STH*CPS+SPH*SPS
  530.       YX=SPH*CTH
  531.       YY=SPH*STH*SPS+CPH*CPS
  532.       YZ=SPH*STH*CPS-CPH*SPS
  533.       ZX=-STH
  534.       ZY=CTH*SPS
  535.       ZZ=CTH*CPS
  536.       NRP=NRPT
  537.       IF (NRPT.EQ.0) NRP=1
  538.       IX=1
  539.       IF (N.LT.N2) GO TO 3
  540. C***
  541. C***    GM STUFF  SELECTED MOVE  RWA 02 APR 89  ADD 4 LINES/REPLACE 3
  542. C***
  543.       IMT1 = IXT1
  544.       IMT2 = IXT2
  545.       IF(IMT2.EQ.0) IMT2 = IMT1
  546.       IF(IMT1.EQ.0) IMT2 = 0
  547.       I1 = N2
  548. CCC   I1=ISEGNO(ITS,1,LD,ITAG)
  549. CCC   IF (I1.LT.N2) I1=N2
  550. CCC   IX=I1
  551.       K=N
  552. CCC   IF (NRPT.EQ.0) K=I1-1
  553.       DO 2 IR=1,NRP
  554.       DO 1 I=I1,N
  555. C***
  556. C***    GM STUFF  SELECTED MOVE  RWA 02 APR 89  ADD 3 LINES/CHANGE 1
  557. C***
  558.       IF(IMT1.EQ.0)GO TO 7
  559.       IF((ITAG(I).LT.IMT1).OR.(ITAG(I).GT.IMT2))GO TO 1
  560. 7     K=K+1
  561.       IF(NRPT.EQ.0)K = I
  562. CCC   K=K+1
  563.       XI=X(I)
  564.       YI=Y(I)
  565.       ZI=Z(I)
  566.       X(K)=XI*XX+YI*XY+ZI*XZ+XS
  567.       Y(K)=XI*YX+YI*YY+ZI*YZ+YS
  568.       Z(K)=XI*ZX+YI*ZY+ZI*ZZ+ZS
  569.       XI=X2(I)
  570.       YI=Y2(I)
  571.       ZI=Z2(I)
  572.       X2(K)=XI*XX+YI*XY+ZI*XZ+XS
  573.       Y2(K)=XI*YX+YI*YY+ZI*YZ+YS
  574.       Z2(K)=XI*ZX+YI*ZY+ZI*ZZ+ZS
  575.       BI(K)=BI(I)
  576.       ITAG(K)=ITAG(I)
  577.       IF(ITAG(I).NE.0)ITAG(K)=ITAG(I)+ITGI
  578. 1     CONTINUE
  579.       I1=N+1
  580. C***
  581. C***    GM STUFF  SELECTED MOVE  RWA 02 APR 89  ADD 1 LINE/CHANGE 1
  582. C***
  583.       IF(NRPT.GT.0)N = K
  584.       IMT1 = 0
  585. CCC   N=K
  586. 2     CONTINUE
  587. 3     IF (M.LT.M2) GO TO 6
  588.       I1=M2
  589.       K=M
  590.       LDI=LD+1
  591.       IF (NRPT.EQ.0) K=M1
  592.       DO 5 II=1,NRP
  593.       DO 4 I=I1,M
  594.       K=K+1
  595.       IR=LDI-I
  596.       KR=LDI-K
  597.       XI=X(IR)
  598.       YI=Y(IR)
  599.       ZI=Z(IR)
  600.       X(KR)=XI*XX+YI*XY+ZI*XZ+XS
  601.       Y(KR)=XI*YX+YI*YY+ZI*YZ+YS
  602.       Z(KR)=XI*ZX+YI*ZY+ZI*ZZ+ZS
  603.       XI=T1X(IR)
  604.       YI=T1Y(IR)
  605.       ZI=T1Z(IR)
  606.       T1X(KR)=XI*XX+YI*XY+ZI*XZ
  607.       T1Y(KR)=XI*YX+YI*YY+ZI*YZ
  608.       T1Z(KR)=XI*ZX+YI*ZY+ZI*ZZ
  609.       XI=T2X(IR)
  610.       YI=T2Y(IR)
  611.       ZI=T2Z(IR)
  612.       T2X(KR)=XI*XX+YI*XY+ZI*XZ
  613.       T2Y(KR)=XI*YX+YI*YY+ZI*YZ
  614.       T2Z(KR)=XI*ZX+YI*ZY+ZI*ZZ
  615.       SALP(KR)=SALP(IR)
  616. 4     BI(KR)=BI(IR)
  617.       I1=M+1
  618. 5     M=K
  619. C***
  620. C***    GM STUFF  SELECTED MOVE  RWA 02 APR 89  CHANGE 1 LINE
  621. C***
  622. 6     IF ((NRPT.EQ.0).AND.(IXT1.EQ.0)) RETURN
  623. CCC6  IF ((NRPT.EQ.0).AND.(IX.EQ.1)) RETURN
  624.       NP=N
  625.       MP=M
  626.       IPSYM=0
  627.       RETURN
  628.       END
  629. C
  630. C
  631. C
  632.       SUBROUTINE REFLC(IX,IY,IZ,ITX,NOP,LD,X,Y,Z,BI,
  633.      1 ITAG,SALP,T1X,T1Y,T1Z,T2X,T2Y,T2Z,X2,Y2,Z2)
  634. C
  635. C     REFLC REFLECTS PARTIAL STRUCTURE ALONG X,Y, OR Z AXES OR ROTATES
  636. C     STRUCTURE TO COMPLETE A SYMMETRIC STRUCTURE.
  637. C
  638.       INTEGER*4 ITAG,N1,N2,N,NP,M1,M2,M,MP,IPSYM
  639.       REAL*8 E1,E2,SAM,CS,SS,XK,YK
  640.       COMMON/DATAD/N1,N2,N,NP,M1,M2,M,MP,IPSYM,WLAM
  641.       DIMENSION T1X(LD),T1Y(LD),T1Z(LD),T2X(LD),T2Y(LD),T2Z(LD),X2(LD),
  642.      1 Y2(LD),Z2(LD),X(LD),Y(LD),Z(LD),BI(LD),SALP(LD),ITAG(LD)
  643.       NP=N
  644.       MP=M
  645.       IPSYM=0
  646.       ITI=ITX
  647.       IF (IX.LT.0) GO TO 19
  648.       IF (NOP.EQ.0) RETURN
  649.       IPSYM=1
  650.       IF (IZ.EQ.0) GO TO 6
  651. C
  652. C     REFLECT ALONG Z AXIS
  653. C
  654.       IPSYM=2
  655.       IF (N.LT.N2) GO TO 3
  656.       DO 2 I=N2,N
  657.       NX=I+N-N1
  658.       E1=Z(I)
  659.       E2=Z2(I)
  660.       IF((ABS(E1)+ABS(E2)).GT.1.D-5.AND.(E1*E2).GE.-1.D-6) GO TO 1
  661.       WRITE(*,24)  I
  662.       STOP
  663. 1     X(NX)=X(I)
  664.       Y(NX)=Y(I)
  665.       Z(NX)=-E1
  666.       X2(NX)=X2(I)
  667.       Y2(NX)=Y2(I)
  668.       Z2(NX)=-E2
  669.       ITAGI=ITAG(I)
  670.       IF (ITAGI.EQ.0) ITAG(NX)=0
  671.       IF (ITAGI.NE.0) ITAG(NX)=ITAGI+ITI
  672. 2     BI(NX)=BI(I)
  673.       N=N*2-N1
  674.       ITI=ITI*2
  675. 3     IF (M.LT.M2) GO TO 6
  676.       NXX=LD+1-M1
  677.       DO 5 I=M2,M
  678.       NXX=NXX-1
  679.       NX=NXX-M+M1
  680.       IF (ABS(Z(NXX)).GT.1.E-10) GO TO 4
  681.       WRITE(*,25)  I
  682.       STOP
  683. 4     X(NX)=X(NXX)
  684.       Y(NX)=Y(NXX)
  685.       Z(NX)=-Z(NXX)
  686.       T1X(NX)=T1X(NXX)
  687.       T1Y(NX)=T1Y(NXX)
  688.       T1Z(NX)=-T1Z(NXX)
  689.       T2X(NX)=T2X(NXX)
  690.       T2Y(NX)=T2Y(NXX)
  691.       T2Z(NX)=-T2Z(NXX)
  692.       SALP(NX)=-SALP(NXX)
  693. 5     BI(NX)=BI(NXX)
  694.       M=M*2-M1
  695. 6     IF (IY.EQ.0) GO TO 12
  696. C
  697. C     REFLECT ALONG Y AXIS
  698. C
  699.       IF (N.LT.N2) GO TO 9
  700.       DO 8 I=N2,N
  701.       NX=I+N-N1
  702.       E1=Y(I)
  703.       E2=Y2(I)
  704.       IF((ABS(E1)+ABS(E2)).GT.1.D-5.AND.(E1*E2).GE.-1.D-6) GO TO 7
  705.       WRITE(*,24)  I
  706.       STOP
  707. 7     X(NX)=X(I)
  708.       Y(NX)=-E1
  709.       Z(NX)=Z(I)
  710.       X2(NX)=X2(I)
  711.       Y2(NX)=-E2
  712.       Z2(NX)=Z2(I)
  713.       ITAGI=ITAG(I)
  714.       IF (ITAGI.EQ.0) ITAG(NX)=0
  715.       IF (ITAGI.NE.0) ITAG(NX)=ITAGI+ITI
  716. 8     BI(NX)=BI(I)
  717.       N=N*2-N1
  718.       ITI=ITI*2
  719. 9     IF (M.LT.M2) GO TO 12
  720.       NXX=LD+1-M1
  721.       DO 11 I=M2,M
  722.       NXX=NXX-1
  723.       NX=NXX-M+M1
  724.       IF (ABS(Y(NXX)).GT.1.E-10) GO TO 10
  725.       WRITE(*,25)  I
  726.       STOP
  727. 10    X(NX)=X(NXX)
  728.       Y(NX)=-Y(NXX)
  729.       Z(NX)=Z(NXX)
  730.       T1X(NX)=T1X(NXX)
  731.       T1Y(NX)=-T1Y(NXX)
  732.       T1Z(NX)=T1Z(NXX)
  733.       T2X(NX)=T2X(NXX)
  734.       T2Y(NX)=-T2Y(NXX)
  735.       T2Z(NX)=T2Z(NXX)
  736.       SALP(NX)=-SALP(NXX)
  737. 11    BI(NX)=BI(NXX)
  738.       M=M*2-M1
  739. 12    IF (IX.EQ.0) GO TO 18
  740. C
  741. C     REFLECT ALONG X AXIS
  742. C
  743.       IF (N.LT.N2) GO TO 15
  744.       DO 14 I=N2,N
  745.       NX=I+N-N1
  746.       E1=X(I)
  747.       E2=X2(I)
  748.       IF((ABS(E1)+ABS(E2)).GT.1.D-5.AND.(E1*E2).GE.-1.D-6) GO TO 13
  749.       WRITE(*,24)  I
  750.       STOP
  751. 13    X(NX)=-E1
  752.       Y(NX)=Y(I)
  753.       Z(NX)=Z(I)
  754.       X2(NX)=-E2
  755.       Y2(NX)=Y2(I)
  756.       Z2(NX)=Z2(I)
  757.       ITAGI=ITAG(I)
  758.       IF (ITAGI.EQ.0) ITAG(NX)=0
  759.       IF (ITAGI.NE.0) ITAG(NX)=ITAGI+ITI
  760. 14    BI(NX)=BI(I)
  761.       N=N*2-N1
  762. 15    IF (M.LT.M2) GO TO 18
  763.       NXX=LD+1-M1
  764.       DO 17 I=M2,M
  765.       NXX=NXX-1
  766.       NX=NXX-M+M1
  767.       IF (ABS(X(NXX)).GT.1.E-10) GO TO 16
  768.       WRITE(*,25)  I
  769.       STOP
  770. 16    X(NX)=-X(NXX)
  771.       Y(NX)=Y(NXX)
  772.       Z(NX)=Z(NXX)
  773.       T1X(NX)=-T1X(NXX)
  774.       T1Y(NX)=T1Y(NXX)
  775.       T1Z(NX)=T1Z(NXX)
  776.       T2X(NX)=-T2X(NXX)
  777.       T2Y(NX)=T2Y(NXX)
  778.       T2Z(NX)=T2Z(NXX)
  779.       SALP(NX)=-SALP(NXX)
  780. 17    BI(NX)=BI(NXX)
  781.       M=M*2-M1
  782. 18    RETURN
  783. C
  784. C     REPRODUCE STRUCTURE WITH ROTATION TO FORM CYLINDRICAL STRUCTURE
  785. C
  786. 19    FNOP=NOP
  787.       IPSYM=-1
  788.       SAM=6.283185308D0/FNOP
  789.       CS=DCOS(SAM)
  790.       SS=DSIN(SAM)
  791.       IF (N.LT.N2) GO TO 21
  792.       N=N1+(N-N1)*NOP
  793.       NX=NP+1
  794.       DO 20 I=NX,N
  795.       K=I-NP+N1
  796.       XK=X(K)
  797.       YK=Y(K)
  798.       X(I)=XK*CS-YK*SS
  799.       Y(I)=XK*SS+YK*CS
  800.       Z(I)=Z(K)
  801.       XK=X2(K)
  802.       YK=Y2(K)
  803.       X2(I)=XK*CS-YK*SS
  804.       Y2(I)=XK*SS+YK*CS
  805.       Z2(I)=Z2(K)
  806.       ITAGI=ITAG(K)
  807.       IF (ITAGI.EQ.0) ITAG(I)=0
  808.       IF (ITAGI.NE.0) ITAG(I)=ITAGI+ITI
  809. 20    BI(I)=BI(K)
  810. 21    IF (M.LT.M2) GO TO 23
  811.       M=M1+(M-M1)*NOP
  812.       NX=MP+1
  813.       K=LD+1-M1
  814.       DO 22 I=NX,M
  815.       K=K-1
  816.       J=K-MP+M1
  817.       XK=X(K)
  818.       YK=Y(K)
  819.       X(J)=XK*CS-YK*SS
  820.       Y(J)=XK*SS+YK*CS
  821.       Z(J)=Z(K)
  822.       XK=T1X(K)
  823.       YK=T1Y(K)
  824.       T1X(J)=XK*CS-YK*SS
  825.       T1Y(J)=XK*SS+YK*CS
  826.       T1Z(J)=T1Z(K)
  827.       XK=T2X(K)
  828.       YK=T2Y(K)
  829.       T2X(J)=XK*CS-YK*SS
  830.       T2Y(J)=XK*SS+YK*CS
  831.       T2Z(J)=T2Z(K)
  832.       SALP(J)=SALP(K)
  833. 22    BI(J)=BI(K)
  834. 23    RETURN
  835. C
  836. 24    FORMAT (29H GEOMETRY DATA ERROR--SEGMENT,I5,26H LIES IN PLANE OF S
  837.      1YMMETRY)
  838. 25    FORMAT (27H GEOMETRY DATA ERROR--PATCH,I4,26H LIES IN PLANE OF SYM
  839.      1METRY)
  840.       END
  841. C
  842. C
  843. C
  844.       SUBROUTINE WIRE(X,Y,Z,BI,X2,Y2,Z2,XW1,YW1,ZW1,XW2,YW2,ZW2,
  845.      1 RAD,RDEL,RRAD,ITAG,LD,NS,ITG)
  846. C
  847. C     SUBROUTINE WIRE GENERATES SEGMENT GEOMETRY DATA FOR A STRAIGHT
  848. C     WIRE OF NS SEGMENTS.
  849. C
  850.       REAL*8 DELZ,XW1,YW1,ZW1,XW2,YW2,ZW2,XD,YD,ZD,XS1,XS2,
  851.      1 YS1,YS2,ZS1,ZS2
  852.       INTEGER*4 ITAG,N1,N2,N,NP,M1,M2,M,MP,IPSYM
  853.       COMMON/DATAD/N1,N2,N,NP,M1,M2,M,MP,IPSYM,WLAM
  854.       DIMENSION X2(LD),Y2(LD),Z2(LD),X(LD),Y(LD),Z(LD),BI(LD),ITAG(LD)
  855. C**
  856.       IST=N+1
  857.       N=N+NS
  858.       NP=N
  859.       MP=M
  860.       IPSYM=0
  861.       IF (NS.LT.1) RETURN
  862.       XD=XW2-XW1
  863.       YD=YW2-YW1
  864.       ZD=ZW2-ZW1
  865.       IF (ABS(RDEL-1.).LT.1.E-6) GO TO 1
  866.       DELZ=DSQRT(XD*XD+YD*YD+ZD*ZD)
  867.       XD=XD/DELZ
  868.       YD=YD/DELZ
  869.       ZD=ZD/DELZ
  870.       DELZ=DELZ*(1.-RDEL)/(1.-RDEL**NS)
  871.       RD=RDEL
  872.       GO TO 2
  873. 1     FNS=NS
  874.       XD=XD/FNS
  875.       YD=YD/FNS
  876.       ZD=ZD/FNS
  877.       DELZ=1.
  878.       RD=1.
  879. 2     RADZ=RAD
  880.       XS1=XW1
  881.       YS1=YW1
  882.       ZS1=ZW1
  883.       DO 3 I=IST,N
  884.       ITAG(I)=ITG
  885.       XS2=XS1+XD*DELZ
  886.       YS2=YS1+YD*DELZ
  887.       ZS2=ZS1+ZD*DELZ
  888.       X(I)=XS1
  889.       Y(I)=YS1
  890.       Z(I)=ZS1
  891.       X2(I)=XS2
  892.       Y2(I)=YS2
  893.       Z2(I)=ZS2
  894.       BI(I)=RADZ
  895.       DELZ=DELZ*RD
  896.       RADZ=RADZ*RRAD
  897.       XS1=XS2
  898.       YS1=YS2
  899. 3     ZS1=ZS2
  900.       X2(N)=XW2
  901.       Y2(N)=YW2
  902.       Z2(N)=ZW2
  903.       RETURN
  904.       END
  905.